home *** CD-ROM | disk | FTP | other *** search
/ Floppyshop 2 / Floppyshop - 2.zip / Floppyshop - 2.iso / art&graf.ix / art-0066 / trickfil.m / trickflm.lst < prev    next >
File List  |  1997-04-16  |  30KB  |  1,145 lines
  1. ' *****************************************************************************
  2. '
  3. '   Programm zum Herstellen von kleinen Zeichentrickfilmen
  4. '
  5. '   von Heiko Müller, Mozartstraße 17, 2905 Edewecht
  6. '
  7. datum$="18.06.1988"           ! letztes Bearbeitungsdatum
  8. '
  9. ' *****************************************************************************
  10. '
  11. ON ERROR GOSUB fehler     ! falls es den Ordner "FILME" schon gibt, entsteht
  12. '                         ! in der nächsten Zeile ein Fehler:
  13. MKDIR "FILME"             ! diese ersten Zeilen vor dem Compilieren löschen
  14. GOSUB speicher_einrichten
  15. GOSUB ueberschrift
  16. GOSUB titelbild
  17. '
  18. ' #############################################################################
  19. '
  20. DO                                              ! Hauptprogrammschleife
  21.   '
  22.   i$=INKEY$                                     ! Tastaturabfrage
  23.   IF i$<>""
  24.     l=LEN(i$)
  25.     a=ASC(RIGHT$(i$))
  26.     GOSUB wat_nu_taste                          ! für Tastaturauswertung
  27.   ENDIF
  28.   '
  29.   MOUSE x%,y%,k%
  30.   IF k%
  31.     IF (x%>270 AND x%<520) AND y%>200 AND y%<350 AND NOT block!
  32.       GET 271,201,519,349,undo$                 ! Bild merken für Undo-Funktion
  33.       GOSUB freihand                            ! Freihand als Grundfunktion
  34.     ELSE
  35.       GOSUB wat_nu                              ! für Mausaktionenauswertung
  36.     ENDIF
  37.   ENDIF
  38. LOOP
  39. '
  40. ' #############################################################################
  41. '
  42. PROCEDURE fehler           ! läuft nicht im compilierten Programm!
  43.   IF ERR=-36               ! wenn der einzurichtende Ordner "FILME" schon
  44.     RESUME NEXT            ! besteht, soll in der Zeile hinter dem Befehl
  45.   ENDIF                    ! "MKDIR" weitergemacht werden.
  46. RETURN
  47. '
  48. PROCEDURE wat_nu                    ! hier werden die Mausaktionen ausgewertet
  49.   '
  50.   REPEAT                            ! erst dann weitermachen, wenn Maustaste
  51.   UNTIL MOUSEK=0                    ! losgelassen wird
  52.   '
  53.   IF y%>110
  54.     GET 271,201,519,349,undo$       ! Bild merken für Undo-Funktion
  55.   ENDIF
  56.   '
  57.   IF y%<50 AND NOT block!           ! große Schrift oben angeklickt
  58.     GOSUB ueberschrift
  59.     GOSUB reparatur
  60.   ENDIF
  61.   '
  62.   IF x%>20 AND x%<620 AND y%>50 AND y%<170   ! 12 große Kästen angeklickt
  63.     z=INT((x%-20)/100)+1+INT((y%-50)/60)*6
  64.     IF NOT block!
  65.       ON z GOSUB spei,lad,abspi,must_wa,lin_wa,fig_fuell,fuell,block,kreis,ellipse,gerade,kasten
  66.     ELSE
  67.       IF z=8
  68.         GOSUB block
  69.       ENDIF
  70.     ENDIF
  71.     '
  72.   ENDIF
  73.   '
  74.   IF x%>20 AND y%>360 AND x%<130 AND y%<380     ! Programmende-Kasten
  75.     GOSUB ende
  76.   ENDIF
  77.   '
  78.   IF x%>270 AND x%<362 AND y%>360 AND y%<380    ! Kästen unter rechtem Bild
  79.     z=INT((x%-270)/24)+1
  80.     IF NOT block!
  81.       ON z GOSUB hoch,runter,rechts,links
  82.     ELSE
  83.       b=1
  84.       IF k%=2
  85.         b=5
  86.       ENDIF
  87.       DEFFILL 0,2,8
  88.       PBOX a1%,b1%,a2%,b2%
  89.       ON z GOSUB b_hoch,b_runter,b_rechts,b_links
  90.       PUT a1%,b1%,block$
  91.       GET 271,201,519,349,bild$(bild%)
  92.       '
  93.       IF a1%<270 OR b1%<200 OR a2%>520 OR b2%>350 ! falls Umgebung durch Block
  94.         IF a1%<270                                ! überdeckt ist
  95.           a1%=270
  96.         ENDIF
  97.         IF b1%<200
  98.           b1%=200
  99.         ENDIF
  100.         IF a2%>520
  101.           a2%=520
  102.         ENDIF
  103.         IF b2%>350
  104.           b2%=350
  105.         ENDIF
  106.         GOSUB reparatur
  107.         GET a1%,b1%,a2%,b2%,block$
  108.         GOSUB kasten_schwarz(8)
  109.       ENDIF
  110.       '
  111.       PAUSE 5
  112.     ENDIF
  113.   ENDIF
  114.   '
  115.   IF x%>540 AND x%<620 AND y%>200 AND y%<380      ! Kasten rechts neben Bildern
  116.     z=INT((y%-200)/20)+1
  117.     IF NOT block!
  118.       ON z GOSUB zurueck,vor,merken,einsetzen,loeschen,entfernen,erweitern,alles_weg,zu_bild
  119.       IF z<3
  120.         GET 271,201,519,349,undo$    ! falls vor oder zurück: neues Bild merken
  121.       ENDIF
  122.       IF z>5            ! nach entfernen, erweitern, Film löschen, zu Bild...
  123.         undo$=""        ! kein Undo mehr möglich
  124.       ENDIF
  125.     ELSE
  126.       ON z GOSUB nicht,nicht,b_merken,hier_nicht,b_loeschen,nicht,nicht,nicht,nicht
  127.     ENDIF
  128.   ENDIF
  129.   '
  130.   IF x%>405 AND y%>360 AND x%<460 AND y%<380
  131.     GOSUB kopieren
  132.   ENDIF
  133.   '
  134. RETURN
  135. '
  136. '
  137. PROCEDURE nicht
  138.   OUT 2,7
  139. RETURN
  140. '
  141. PROCEDURE hier_nicht
  142.   ALERT 0,"Das geht erst, wenn die|Blockfunktion wieder|ausgeschaltet ist.",1,"ach so",antw
  143. RETURN
  144. '
  145. PROCEDURE wat_nu_taste
  146.   '
  147.   ' Diese Procedure wird in diesem Programm nur für die Undo-Taste genutzt.
  148.   ' Es ist möglich, hier noch andere Unterprogrammaufrufe zu installieren,
  149.   ' die per Tastendruck ausgelöst werden.
  150.   ' Dazu werden bei Tastendruck die beiden Variablen a und l belegt,
  151.   ' die man sich durch die folgende Programmzeile zur weiteren Bearbeitung
  152.   ' anzeigen lassen kann:
  153.   '
  154.   ' TEXT 20,190," Taste "+i$+" "+STR$(a)+" "+STR$(l)+" "  ! (später löschen)
  155.   '
  156.   IF a=97 AND l=2          ! Wenn die Undo-Taste getippt wurde
  157.     PUT 271,201,undo$
  158.   ENDIF
  159. RETURN
  160. '
  161. PROCEDURE ueberschrift
  162.   CLS
  163.   DEFTEXT 1,16,0,32
  164.   TEXT 10,50,"# Zeichentrickfilmprogramm ##"
  165.   DEFTEXT 1,0,0,4
  166.   TEXT 550,30,"Version "+version$
  167.   TEXT 550,40,"vom"
  168.   TEXT 550,50,datum$
  169.   TEXT 440,380,"Leertaste: weitere Informationen"
  170.   TEXT 440,390,"rechte Maustaste: Hauptprogramm"
  171.   PRINT AT(3,5);
  172.   PRINT "programmiert in GFA-BASIC von Heiko Müller, Mozartstraße 17, 2905 Edewecht"
  173.   PRINT
  174.   PRINT "  Als Grundfunktion ist das Freihand-Malen eingebaut.  Nur das rechte  Bild"
  175.   PRINT "  kann  bearbeitet  werden.  Mit  der rechten Maustaste läßt  sich  in  der"
  176.   PRINT "  eingestellten Strichstärke radieren."
  177.   PRINT "  Mit  den  vier Pfeilfeldern unter dem rechten Bild  wird  der  Bildinhalt"
  178.   PRINT "  verschoben  - mit der linken Maustaste um ein Pixel,  mit der rechten  um"
  179.   PRINT "  fünf."
  180.   PRINT "  Mit  dem Feld rechts daneben wird das linke (das vorhergehende) Bild  auf"
  181.   PRINT "  das bearbeitete Bild kopiert."
  182.   PRINT "  Mit der Funktion >>merken<< wird der momentane Bildinhalt gespeichert zum"
  183.   PRINT "  späteren >>einsetzen<< in ein anderes Bild."
  184.   PRINT "  Mit der Taste 'Undo'  kann man nach Beendigung der meisten Funktionen die"
  185.   PRINT "  letzten Veränderungen rückgängig machen."
  186.   PRINT "  Jedes Bild wird automatisch gespeichert,  wenn man zu einem anderen  Bild"
  187.   PRINT "  vorwärts oder rückwärts geht."
  188.   PRINT "  Aktionen,  bei  denen  das Bild oder Teile des  Bildes  gelöscht  werden,"
  189.   PRINT "  können nur mit der rechten Maustaste ausgelöst werden."
  190.   PRINT
  191.   PRINT "  Zum Speichern muß (!) der Ordner FILME existieren!"
  192.   '
  193.   REPEAT
  194.     i$=INKEY$
  195.   UNTIL MOUSEK=2 OR i$=" "
  196.   IF i$=" "
  197.     GOSUB weitere_infos
  198.   ENDIF
  199.   DEFTEXT 1,0,0,13
  200.   CLS
  201. RETURN
  202. '
  203. PROCEDURE weitere_infos
  204.   CLS
  205.   PAUSE 30
  206.   PRINT AT(3,2);
  207.   PRINT "Dieses  Programm  darf  mitsamt dem Quellcode beliebig  oft  kopiert  und"
  208.   PRINT "  weitergegeben werden.  Ich selbst habe mich auch oft über andere  GfA-PD-"
  209.   PRINT "  Programme gefreut und daraus auch gerne Teile übernommen."
  210.   PRINT
  211.   PRINT "  Da ich wohl Freude am Programmieren habe,  jedoch nicht am Herstellen von"
  212.   PRINT "  Zeichentrickfilmen,  habe ich als Beispiel nur den 'Pferdefilm'  übernom-"
  213.   PRINT "  men,  den  man auf der Original-BASIC-Diskette findet.  Falls jemand  das"
  214.   PRINT "  Programm  so gut findet,  daß er mir auch einen Gefallen tun  möchte,  so"
  215.   PRINT "  kann er mir ja mal eine Diskette mit eigenen Filmen schicken. Auch andere"
  216.   PRINT "  'selbstgestrickte' GfA-BASIC-Programme nehme ich natürlich gerne an."
  217.   PRINT
  218.   PRINT "  Heiko Müller"
  219.   PRINT "  Mozartstraße 17"
  220.   PRINT "  2905 Edewecht"
  221.   DEFTEXT 1,0,0,4
  222.   TEXT 440,380,"Leertaste oder Mausklick"
  223.   REPEAT
  224.     i$=INKEY$
  225.   UNTIL MOUSEK OR i$=" "
  226.   DEFTEXT 1,0,0,13
  227.   CLS
  228. RETURN
  229. '
  230. PROCEDURE freihand                     ! Diese Procedure wird als Grundfunktion
  231.   DEFLINE 1,breite,2,2                 ! immer angesteuert
  232.   COLOR 1
  233.   IF k%>1
  234.     COLOR 0
  235.   ENDIF
  236.   PLOT x%,y%
  237.   IF merk%=bild%
  238.     text$=" Altes Bild "+STR$(bild%)+" gemerkt"
  239.   ENDIF
  240.   WHILE (x%>270 AND x%<520) AND y%>200 AND y%<350 AND MOUSEK>0
  241.     DRAW  TO x%,y%
  242.     MOUSE x%,y%,k%
  243.   WEND
  244.   COLOR 1
  245.   GET 271,201,519,349,bild$(bild%)
  246. RETURN
  247. '
  248. PROCEDURE spei
  249.   GET 271,201,519,349,bild$(bild%)
  250.   GOSUB kasten_schwarz(1)
  251.   frei=INT(DFREE(0)/1024)           ! freien Platz auf der Diskette ermitteln
  252.   groesse=0
  253.   FOR i%=0 TO schluss               ! Filmlänge ermitteln
  254.     groesse=groesse+LEN(bild$(i%))
  255.   NEXT i%
  256.   groesse=INT(groesse/1024+1)
  257.   al$="Filmlänge: "+STR$(groesse)+" KByte |"
  258.   al$=al$+"freier Platz auf der Diskette:|"+SPACE$(11)+STR$(frei)+" KByte"
  259.   ALERT 0,al$,1," aha ",antw
  260.   IF frei<groesse
  261.     ALERT 3,"Nicht genug Platz| auf der Diskette!| |Soll etwas gelöscht werden?",1,"Abbruch|löschen",antw
  262.     IF antw=2
  263.       FILESELECT "A:\FILME\*.*","",name$
  264.       IF LEN(name$)>0
  265.         ALERT 3," Die Datei        | "+name$+"| löschen ?",1,"Nein| Ja ",antw
  266.         IF antw=2
  267.           KILL name$
  268.         ENDIF
  269.       ENDIF
  270.     ENDIF
  271.   ENDIF
  272.   IF frei>groesse
  273.     IF bild$(endbild%)=bild$(0)            ! leeres Bild am Ende löschen
  274.       bild$(endbild%)=""
  275.       DEC endbild%
  276.     ENDIF
  277.     FILESELECT "A:\FILME\*.FLM","",name$
  278.     IF LEN(name$)>0
  279.       PUT 21,201,bild$(0)
  280.       IF INSTR(name$,".")=0             ! falls im Namen kein Punkt vorkommt,
  281.         name$=name$+".FLM"              ! FLM dranhängen
  282.       ENDIF
  283.       OPEN "O",#1,name$
  284.       DEFMOUSE 2
  285.       '
  286.       ' die folgende Routine stammt aus dem Buch "GFA BASIC" von F. Ostrowski,
  287.       ' ebenso wie die dazugehörige Laderoutine in der nächsten Procedure
  288.       '
  289.       FOR i%=0 TO schluss
  290.         PRINT #1,MKI$(LEN(bild$(i%)));bild$(i%);
  291.         IF bild$(i%)<>""
  292.           TEXT 270,195," Bild "+STR$(i%)+"                  "
  293.           PUT 271,201,bild$(i%)
  294.         ENDIF
  295.       NEXT i%
  296.       CLOSE #1
  297.     ENDIF
  298.   ENDIF
  299.   bild%=1
  300.   GOSUB reparatur
  301. RETURN
  302. '
  303. PROCEDURE lad
  304.   GOSUB kasten_schwarz(z)
  305.   FILESELECT "A:\FILME\*.FLM","",name$
  306.   IF EXIST(name$)                           ! Datei existiert?
  307.     OPEN "I",#1,name$
  308.     FOR i%=0 TO schluss
  309.       bild$(i%)=INPUT$(CVI(INPUT$(2,#1)),#1)
  310.       IF bild$(i%)<>""               ! durch Hochzählen der vollen Bilder
  311.         endbild%=i%                  ! Gesamtbildzahl ermitteln
  312.         TEXT 270,195," Bild "+STR$(i%)+"                         "
  313.         PUT 271,201,bild$(i%)        ! geladene Bilder gleich anzeigen
  314.       ENDIF
  315.     NEXT i%
  316.     bild%=1
  317.   ENDIF
  318.   CLOSE #1
  319.   GOSUB reparatur
  320. RETURN
  321. '
  322. PROCEDURE abspi
  323.   GOSUB kasten_schwarz(z)
  324.   IF bild$(endbild%)=bild$(0)            ! leeres Bild am Ende löschen
  325.     bild$(endbild%)=""
  326.     DEC endbild%
  327.   ENDIF
  328.   ALERT 0,"  Film abspielen  | | In welche Richtung? |  ",2,"  ⇨  | ⇨ ⇦ |  ⇦  ",antw
  329.   DEFFILL 1,2,8
  330.   p=0
  331.   PBOX 0,0,639,399
  332.   TEXT 0,395," linke Maustaste: schneller  *  rechts: langsamer  *  beide:  Stop  * Tempo "+STR$(20-p)+"  "
  333.   HIDEM
  334.   REPEAT
  335.     IF antw<3
  336.       FOR i%=1 TO endbild%               ! Vorwärtsvorführung
  337.         PUT 195,100,bild$(i%)
  338.         PAUSE p
  339.         MOUSE x%,y%,k%
  340.         IF k%
  341.           GOSUB tempo
  342.         ENDIF
  343.         EXIT IF MOUSEK>2
  344.       NEXT i%
  345.     ENDIF
  346.     EXIT IF k%>2
  347.     IF antw>1
  348.       FOR i%=endbild% DOWNTO 1           ! Rückwärtsvorführung
  349.         PUT 195,100,bild$(i%)
  350.         PAUSE p
  351.         MOUSE x%,y%,k%
  352.         IF k%
  353.           GOSUB tempo
  354.         ENDIF
  355.         EXIT IF k%>2
  356.       NEXT i%
  357.     ENDIF
  358.   UNTIL MOUSEK>2
  359.   bild%=1
  360.   GOSUB reparatur
  361.   PUT 271,201,bild$(bild%)
  362.   TEXT 270,195," Bild "+STR$(bild%)+" (von "+STR$(endbild%)+")    "
  363.   REPEAT
  364.   UNTIL MOUSEK=0
  365.   SHOWM
  366. RETURN
  367. '
  368. PROCEDURE tempo
  369.   IF k%=2
  370.     DEC p
  371.     IF p<0
  372.       p=0
  373.     ENDIF
  374.   ENDIF
  375.   IF k%=1
  376.     INC p
  377.     IF p>20
  378.       p=20
  379.     ENDIF
  380.   ENDIF
  381.   TEXT 0,395," linke Maustaste: langsamer  *  rechts: schneller  *  beide:  Stop  * Tempo "+STR$(20-p)+"  "
  382. RETURN
  383. '
  384. PROCEDURE must_wa
  385.   DEFMOUSE 0
  386.   musterdaten:
  387.   DATA 2,1,2,2,2,3,2,4,2,5,2,6
  388.   DATA 2,7,2,8,2,9,2,10,2,11,2,12
  389.   DATA 2,13,2,14,2,15,2,16,2,17,2,18
  390.   DATA 2,19,2,20,2,21,2,22,2,23,2,24
  391.   DATA 3,1,3,2,3,3,3,4,3,5,3,6
  392.   DATA 3,7,3,8,3,9,3,10,3,11,3,12,4,1,0,0,0,0
  393.   RESTORE musterdaten
  394.   GRAPHMODE 1
  395.   FOR i%=0 TO 37
  396.     READ muster1,muster2
  397.     DEFFILL 1,muster1,muster2
  398.     PBOX i%*16.8,50,i%*16.8+16.8,110
  399.   NEXT i%
  400.   REPEAT
  401.     MOUSE x%,y%,k%
  402.     x%=INT(x%/16.8)
  403.   UNTIL k% AND y%>40 AND y%<110
  404.   RESTORE musterdaten
  405.   FOR i%=1 TO x%+1
  406.     READ muster1,muster2
  407.   NEXT i%
  408.   DEFFILL 1,muster1,muster2
  409.   PBOX 0,50,640,110
  410.   PAUSE 10
  411.   REPEAT
  412.   UNTIL MOUSEK=0
  413.   GOSUB reparatur
  414. RETURN
  415. '
  416. PROCEDURE lin_wa
  417.   IF k%=1
  418.     INC breite
  419.   ELSE
  420.     DEC breite
  421.   ENDIF
  422.   IF breite<1
  423.     breite=1
  424.   ENDIF
  425.   IF breite>20
  426.     breite=20
  427.   ENDIF
  428.   TEXT 449,95,"("+STR$(breite)+")  "
  429.   PAUSE 5
  430. RETURN
  431. '
  432. PROCEDURE fig_fuell
  433.   GOSUB kasten_schwarz(6)
  434.   figurfuellen!=NOT figurfuellen!
  435. RETURN
  436. '
  437. PROCEDURE fuell
  438.   fuell_undo$=undo$
  439.   DEFMOUSE 3
  440.   GRAPHMODE 3
  441.   DEFFILL 1,2,8
  442.   PBOX 20,110,120,140
  443.   GRAPHMODE 1
  444.   DEFFILL 1,muster1,muster2
  445.   TEXT 270,195,"Ende der Füllfunktion durch rechte Maustaste  "
  446.   DO
  447.     MOUSE x%,y%,k%
  448.     EXIT IF k%>1
  449.     i$=INKEY$
  450.     IF i$<>""
  451.       IF ASC(RIGHT$(i$))=97 AND LEN(i$)=2
  452.         PUT 271,201,fuell_undo$
  453.         GET 271,201,519,349,bild$(bild%)
  454.       ENDIF
  455.     ENDIF
  456.     '
  457.     '
  458.     IF x%>540 AND x%<620 AND y%>200 AND y%<240 AND k%  ! Kasten rechts neben
  459.       z=INT((y%-200)/20)+1                             ! Bildschirm
  460.       ON z GOSUB zurueck,vor
  461.       DEFMOUSE 3
  462.       GRAPHMODE 3
  463.       DEFFILL 1,2,8
  464.       PBOX 20,110,120,140
  465.       GRAPHMODE 1
  466.       DEFFILL 1,muster1,muster2
  467.       TEXT 270,195,"Ende der Füllfunktion durch rechte Maustaste  "
  468.     ENDIF
  469.     '
  470.     IF x%>270 AND x%<520 AND y%>200 AND y%<350 AND k%=1
  471.       IF merk%=bild%
  472.         text$=" Altes Bild "+STR$(bild%)+" gemerkt"
  473.       ENDIF
  474.       GET 271,201,519,349,fuell_undo$
  475.       TEXT 20,195,"letztes Bild mit 'Undo'-Taste"
  476.       FILL x%,y%
  477.       GET 271,201,519,349,bild$(bild%)
  478.     ENDIF
  479.   LOOP
  480.   TEXT 270,195,SPACE$(45)
  481.   GOSUB reparatur
  482.   REPEAT
  483.   UNTIL MOUSEK=0
  484.   DEFMOUSE 0
  485. RETURN
  486. '
  487. PROCEDURE block
  488.   GOSUB kasten_schwarz(8)
  489.   block!=NOT block!                  ! Wechsel zwischen -1 und 0
  490.   IF block!
  491.     block_undo$=undo$                ! sonst gerät Bild mit Rahmen in undo$
  492.     DEFFILL 0,2,8                    ! weiß gefüllten Kasten
  493.     PBOX 1,1,639,109                 ! oben ins Menü setzen
  494.     PRINT AT(26,3);"Bitte jetzt den Block markieren!"
  495.     DEFMOUSE 5
  496.     GOSUB gummikasten
  497.     a1%=x%
  498.     b1%=y%
  499.     a2%=x1%
  500.     b2%=y1%
  501.     IF a1%<270                           ! falls der Block im linken Bild sitzt
  502.       linksblock!=TRUE
  503.       IF a2%>270
  504.         a2%=270
  505.       ENDIF
  506.     ENDIF
  507.     GRAPHMODE 3
  508.     PRINT AT(10,2);"Es stehen für den Block nicht alle Funktionen zur Verfügung!"
  509.     PRINT AT(10,3);"Er läßt sich verschieben mit den Pfeilfeldern, löschen"
  510.     PRINT AT(10,4);"oder merken zum späteren Einsetzen."
  511.     PRINT AT(10,6);"Ende der Blockfunktion durch nochmaliges Anklicken des Blockfeldes"
  512.     IF linksblock!
  513.       OUT 2,7
  514.       PRINT AT(10,4);"   Dieser Block kann nur nach rechts kopiert werden."
  515.       PRINT AT(10,2);SPACE$(69)
  516.       PRINT AT(10,3);SPACE$(69)
  517.       PRINT AT(10,6);"Ende der Blockfunktion durch nochmaliges Anklicken des Blockfeldes"
  518.     ENDIF
  519.     '
  520.     DEFLINE 1,1,0,0
  521.     BOX a1%,b1%,a2%,b2%               ! Block einrahmen
  522.     GET a1%,b1%,a2%,b2%,block$
  523.     GRAPHMODE 1
  524.     DEFMOUSE 0
  525.   ELSE                                ! falls Block wieder ausgeschaltet wird
  526.     GRAPHMODE 3                       ! neuen Rahmen zum Verdecken des alten
  527.     DEFLINE 1,1,0,0
  528.     BOX a1%,b1%,a2%,b2%
  529.     GRAPHMODE 1
  530.     GET 271,201,519,349,bild$(bild%)
  531.     GOSUB reparatur
  532.     undo$=block_undo$
  533.   ENDIF
  534.   IF linksblock!
  535.     GOSUB linksblock
  536.   ENDIF
  537. RETURN
  538. '
  539. PROCEDURE linksblock
  540.   REPEAT
  541.     MOUSE x%,y%,k%
  542.   UNTIL k% AND ((x%>120 AND x%<220 AND y%>110 AND y%<170) OR (x%>405 AND x%<460 AND y%>360 AND y%<380))
  543.   IF (x%>120 AND x%<220 AND y%>110 AND y%<170)
  544.   ENDIF
  545.   IF x%>405 AND y%>360 AND x%<460 AND y%<380
  546.     GET a1%+1,b1%+1,a2%-1,b2%-1,block$
  547.     PUT a1%+251,b1%,block$
  548.   ENDIF
  549.   linksblock!=FALSE
  550.   z=8
  551.   GOSUB block
  552.   REPEAT
  553.   UNTIL MOUSEK=0
  554. RETURN
  555. '
  556. PROCEDURE kreis
  557.   GOSUB kasten_schwarz(9)
  558.   DEFMOUSE 7
  559.   DEFLINE 1,1,0,0
  560.   TEXT 270,195,"Ende der Funktion durch rechte Maustaste    "
  561.   DO
  562.     MOUSE x%,y%,k%
  563.     EXIT IF k%>1
  564.     IF x%>520 AND x%<620 AND y%>50 AND y%<110 AND k%=1
  565.       GOSUB fig_fuell
  566.     ENDIF
  567.     IF k%=1
  568.       IF merk%=bild%
  569.         text$=" Altes Bild "+STR$(bild%)+" gemerkt"
  570.       ENDIF
  571.       DEFLINE 1,1,0,0
  572.       REPEAT
  573.         MOUSE x%,y%,k%
  574.       UNTIL k%=1
  575.       GRAPHMODE 3
  576.       PAUSE 10
  577.       REPEAT
  578.         MOUSE x1%,y1%,k%
  579.         radius=ABS(x1%-x%)
  580.         CIRCLE x%,y%,radius
  581.         PAUSE 2
  582.         CIRCLE x%,y%,radius
  583.       UNTIL k%<>1
  584.       GRAPHMODE 1
  585.       DEFLINE 1,breite,2,2
  586.       DEFFILL 1,muster1,muster2
  587.       IF figurfuellen!
  588.         PCIRCLE x%,y%,ABS(x1%-x%)
  589.       ELSE
  590.         CIRCLE x%,y%,ABS(x1%-x%)
  591.       ENDIF
  592.       PAUSE 5
  593.     ENDIF
  594.   LOOP
  595.   GET 271,201,519,349,bild$(bild%)
  596.   DEFMOUSE 0
  597.   TEXT 270,195,SPACE$(45)
  598.   GOSUB reparatur
  599.   REPEAT
  600.   UNTIL MOUSEK=0
  601. RETURN
  602. '
  603. PROCEDURE ellipse
  604.   GOSUB kasten_schwarz(10)
  605.   DEFMOUSE 7
  606.   TEXT 270,195,"Ende der Funktion durch rechte Maustaste    "
  607.   DO
  608.     MOUSE x%,y%,k%
  609.     EXIT IF k%>1
  610.     IF x%>520 AND x%<620 AND y%>50 AND y%<110 AND k%=1
  611.       GOSUB fig_fuell
  612.     ENDIF
  613.     IF k%=1
  614.       IF merk%=bild%
  615.         text$=" Altes Bild "+STR$(bild%)+" gemerkt"
  616.       ENDIF
  617.       DEFLINE 1,1,0,0
  618.       REPEAT
  619.         MOUSE x%,y%,k%
  620.       UNTIL k%=1
  621.       GRAPHMODE 3
  622.       PAUSE 10
  623.       REPEAT
  624.         MOUSE x1%,y1%,k%
  625.         ELLIPSE x%,y%,ABS(x1%-x%),ABS(y1%-y%)
  626.         PAUSE 2
  627.         ELLIPSE x%,y%,ABS(x1%-x%),ABS(y1%-y%)
  628.       UNTIL k%<>1
  629.       GRAPHMODE 1
  630.       DEFLINE 1,breite,2,2
  631.       DEFFILL 1,muster1,muster2
  632.       IF figurfuellen!
  633.         PELLIPSE x%,y%,ABS(x1%-x%),ABS(y1%-y%)
  634.       ELSE
  635.         ELLIPSE x%,y%,ABS(x1%-x%),ABS(y1%-y%)
  636.       ENDIF
  637.       PAUSE 5
  638.     ENDIF
  639.   LOOP
  640.   GET 271,201,519,349,bild$(bild%)
  641.   DEFMOUSE 0
  642.   TEXT 270,195,SPACE$(45)
  643.   GOSUB reparatur
  644.   REPEAT
  645.   UNTIL MOUSEK=0
  646. RETURN
  647. '
  648. PROCEDURE gerade
  649.   GOSUB kasten_schwarz(11)
  650.   DEFMOUSE 5
  651.   DEFLINE 1,1,0,0
  652.   TEXT 270,195,"Ende der Funktion durch rechte Maustaste    "
  653.   DO
  654.     MOUSE x%,y%,k%
  655.     EXIT IF k%>1
  656.     IF x%>270 AND x%<520 AND y%>200 AND y%<350 AND k%=1
  657.       IF merk%=bild%
  658.         text$=" Altes Bild "+STR$(bild%)+" gemerkt"
  659.       ENDIF
  660.       DEFLINE 1,1,0,0
  661.       GRAPHMODE 3
  662.       PAUSE 10
  663.       REPEAT
  664.         MOUSE x1%,y1%,k%
  665.         IF x1%<270
  666.           x1%=270
  667.         ENDIF
  668.         IF x1%>520
  669.           x1%=520
  670.         ENDIF
  671.         IF y1%>350
  672.           y1%=350
  673.         ENDIF
  674.         IF y1%<200
  675.           y1%=200
  676.         ENDIF
  677.         LINE x%,y%,x1%,y1%
  678.         PAUSE 2
  679.         LINE x%,y%,x1%,y1%
  680.       UNTIL k%<>1
  681.       GRAPHMODE 1
  682.       DEFLINE 1,breite,2,2
  683.       LINE x%,y%,x1%,y1%
  684.       PAUSE 5
  685.     ENDIF
  686.   LOOP
  687.   GET 271,201,519,349,bild$(bild%)
  688.   TEXT 270,195,SPACE$(45)
  689.   GOSUB reparatur
  690.   REPEAT
  691.   UNTIL MOUSEK=0
  692. RETURN
  693. '
  694. '
  695. PROCEDURE kasten
  696.   GOSUB kasten_schwarz(12)
  697.   DEFMOUSE 5
  698.   DEFLINE 1,1,0,0
  699.   TEXT 270,195,"Ende der Funktion durch rechte Maustaste    "
  700.   DO
  701.     MOUSE x%,y%,k%
  702.     EXIT IF k%>1
  703.     IF x%>520 AND x%<620 AND y%>50 AND y%<110 AND k%=1
  704.       GOSUB fig_fuell
  705.     ENDIF
  706.     IF x%>20 AND x%<520 AND y%>200 AND y%<350 AND k%=1
  707.       IF merk%=bild%
  708.         text$=" Altes Bild "+STR$(bild%)+" gemerkt"
  709.       ENDIF
  710.       GOSUB gummikasten
  711.       GRAPHMODE 1
  712.       DEFLINE 1,breite,2,2
  713.       DEFFILL 1,muster1,muster2
  714.       IF figurfuellen!
  715.         PBOX x%,y%,x1%,y1%
  716.       ELSE
  717.         BOX x%,y%,x1%,y1%
  718.       ENDIF
  719.       PAUSE 5
  720.     ENDIF
  721.   LOOP
  722.   GET 271,201,519,349,bild$(bild%)
  723.   TEXT 270,195,SPACE$(45)
  724.   GOSUB reparatur
  725.   REPEAT
  726.   UNTIL MOUSEK=0
  727. RETURN
  728. '
  729. PROCEDURE gummikasten
  730.   DEFLINE 1,1,0,0
  731.   REPEAT
  732.     MOUSE x%,y%,k%
  733.   UNTIL k% AND x%>20 AND x%<520 AND y%>200 AND y%<350
  734.   GRAPHMODE 3
  735.   PAUSE 10
  736.   REPEAT
  737.     MOUSE x1%,y1%,k%
  738.     IF x1%<20
  739.       x1%=20
  740.     ENDIF
  741.     IF x1%>520
  742.       x1%=520
  743.     ENDIF
  744.     IF y1%>350
  745.       y1%=350
  746.     ENDIF
  747.     IF y1%<200
  748.       y1%=200
  749.     ENDIF
  750.     BOX x%,y%,x1%,y1%
  751.     PAUSE 2
  752.     BOX x%,y%,x1%,y1%
  753.   UNTIL k%<>1
  754.   IF x1%<x%
  755.     SWAP x1%,x%
  756.   ENDIF
  757.   IF y1%<y%
  758.     SWAP y1%,y%
  759.   ENDIF
  760. RETURN
  761. '
  762. PROCEDURE kasten_schwarz(z)
  763.   IF z>6
  764.     y%=110
  765.     SUB z,6
  766.   ELSE
  767.     y%=50
  768.   ENDIF
  769.   x%=100*z-80
  770.   GRAPHMODE 3
  771.   DEFFILL 1,2,8
  772.   PBOX x%,y%,x%+100,y%+60
  773.   GRAPHMODE 1
  774. RETURN
  775. '
  776. PROCEDURE merken
  777.   GET 271,201,519,349,merk$
  778.   merk%=bild%
  779.   text$=" Bild "+STR$(bild%)+" gemerkt          "
  780.   TEXT 430,195,text$
  781.   block_gemerkt!=FALSE
  782. RETURN
  783. '
  784. PROCEDURE einsetzen
  785.   IF merk$=""
  786.     ALERT 0,"Es ist kein Bild gemerkt!",1,"ach so",antw
  787.   ELSE
  788.     IF block_gemerkt!
  789.       GOSUB b_einsetzen
  790.     ELSE
  791.       GET 271,201,519,349,bild$(bild%)      ! zum Untersuchen, ob Bild leer ist
  792.       REPEAT
  793.       UNTIL MOUSEK=0
  794.       IF bild$(bild%)<>bild$(0) AND k%=2
  795.         PUT 271,201,merk$
  796.       ENDIF
  797.       IF bild$(bild%)=bild$(0)
  798.         PUT 271,201,merk$
  799.       ENDIF
  800.     ENDIF
  801.   ENDIF
  802.   GET 271,201,519,349,bild$(bild%)
  803. RETURN
  804. '
  805. PROCEDURE zurueck
  806.   IF bild%>1
  807.     GET 271,201,519,349,bild$(bild%)
  808.     DEC bild%
  809.   ENDIF
  810.   '
  811.   GOSUB reparatur
  812.   '
  813.   PAUSE 5
  814. RETURN
  815. '
  816. PROCEDURE vor
  817.   GET 271,201,519,349,bild$(bild%)
  818.   IF bild%<schluss AND bild$(bild%)<>bild$(0)
  819.     INC bild%                     ! Bild weiterzählen
  820.     IF bild$(bild%)=""            ! falls neues Bild nichts enthält:
  821.       INC endbild%                ! Endbildnummer erhöhen
  822.       bild$(bild%)=bild$(0)       ! Leerbild auf neues Bild
  823.       IF bild%=schluss
  824.         REPEAT
  825.         UNTIL MOUSEK=0
  826.         ALERT 0,"Das ist das letzte Bild",1," na ja ",antw
  827.       ENDIF
  828.     ENDIF
  829.     '
  830.     GOSUB reparatur
  831.     '
  832.   ENDIF
  833.   PAUSE 5
  834. RETURN
  835. '
  836. PROCEDURE loeschen
  837.   IF k%=2
  838.     bild$(bild%)=bild$(0)
  839.     PUT 271,201,bild$(0)
  840.   ENDIF
  841. RETURN
  842. '
  843. PROCEDURE entfernen                       ! hier wird ein Bild ganz gelöscht,
  844.   IF k%=2                                 ! indem die folgenden Bilder
  845.     FOR i%=bild% TO endbild%              ! um ein Bild vorrücken
  846.       bild$(i%)=bild$(i%+1)
  847.     NEXT i%
  848.     IF endbild%=bild% AND bild%>1
  849.       DEC bild%
  850.     ENDIF
  851.     IF endbild%>1
  852.       DEC endbild%
  853.     ENDIF
  854.     REPEAT
  855.     UNTIL MOUSEK=0
  856.     GOSUB reparatur
  857.   ENDIF
  858. RETURN
  859. '
  860. PROCEDURE erweitern                ! hier wird ein leeres Bild zwischengefügt
  861.   IF bild$(bild%)<>bild$(0)        ! indem die folgenden Bilder um ein Bild
  862.     INC endbild%                   ! nach hinten rücken
  863.     FOR i%=endbild% DOWNTO bild%
  864.       bild$(i%)=bild$(i%-1)
  865.     NEXT i%
  866.     IF endbild%>schluss
  867.       bild$(endbild%)=""
  868.       DEC endbild%
  869.     ENDIF
  870.     bild$(bild%)=bild$(0)
  871.     GOSUB reparatur
  872.   ENDIF
  873. RETURN
  874. '
  875. PROCEDURE alles_weg
  876.   ALERT 0,"Den ganzen Film löschen? ",2,"  ja  | nein ",antw
  877.   IF antw=1
  878.     FOR i%=1 TO schluss
  879.       bild$(i%)=""
  880.     NEXT i%
  881.     bild$(1)=bild$(0)
  882.     bild%=1
  883.     endbild%=1
  884.     PUT 21,201,bild$(0)
  885.     PUT 271,201,bild$(1)
  886.     TEXT 270,195," Bild "+STR$(bild%)+" (von "+STR$(endbild%)+")   "
  887.   ENDIF
  888. RETURN
  889. '
  890. '
  891. FOR i%=200 TO 360 STEP 20                      ! Kästen rechts neben Bildern
  892.   BOX 540,i%,620,i%+20
  893. NEXT i%
  894. '
  895. PROCEDURE zu_bild                    ! zu eingegebenem Bild gehen
  896.   GET 271,201,519,349,bild$(bild%)
  897.   DEFFILL 1,2,1
  898.   PBOX 540,360,635,390
  899.   HIDEM
  900.   PRINT AT(69,24);"zu Bild:";
  901.   FORM INPUT 3,i$
  902.   bild%=VAL(i$)
  903.   IF bild%>endbild%
  904.     bild%=endbild%
  905.   ENDIF
  906.   IF bild%<1
  907.     bild%=1
  908.   ENDIF
  909.   SHOWM
  910.   GOSUB reparatur
  911. RETURN
  912. '
  913. PROCEDURE kopieren
  914.   IF NOT block!
  915.     GET 271,201,519,349,bild$(bild%)
  916.     antw=0
  917.     IF (bild$(bild%)<>bild$(0) AND k%=2) OR (bild$(bild%)=bild$(0))
  918.       PUT 271,201,bild$(bild%-1)
  919.     ENDIF
  920.   ENDIF
  921. RETURN
  922. '
  923. PROCEDURE hoch
  924.   IF k%=1
  925.     GET 271,202,519,349,schieb$
  926.   ELSE
  927.     GET 271,206,519,349,schieb$
  928.   ENDIF
  929.   PUT 271,201,bild$(0)
  930.   PUT 271,201,schieb$
  931. RETURN
  932. '
  933. PROCEDURE runter
  934.   IF k%=1
  935.     GET 271,201,519,348,schieb$
  936.   ELSE
  937.     GET 271,201,519,344,schieb$
  938.   ENDIF
  939.   PUT 271,201,bild$(0)
  940.   PUT 271,202-4*(k%>1),schieb$
  941. RETURN
  942. '
  943. PROCEDURE rechts
  944.   IF k%=1
  945.     GET 271,201,518,349,schieb$
  946.   ELSE
  947.     GET 271,201,514,349,schieb$
  948.   ENDIF
  949.   PUT 271,201,bild$(0)
  950.   PUT 272-4*(k%>1),201,schieb$
  951. RETURN
  952. '
  953. PROCEDURE links
  954.   IF k%=1
  955.     GET 272,201,519,349,schieb$
  956.   ELSE
  957.     GET 276,201,519,349,schieb$
  958.   ENDIF
  959.   PUT 271,201,bild$(0)
  960.   PUT 271,201,schieb$
  961. RETURN
  962. '
  963. PROCEDURE speicher_einrichten
  964.   schluss=100                       ! letzter Bildspeicher
  965.   DIM bild$(schluss+1)              ! Bildspeicher
  966.   bild%=1                           ! Nummer des bearbeiteten Bildes
  967.   endbild%=1                        ! höchste Bildnummer
  968.   '
  969.   breite=1                          ! Strichstärke
  970.   muster1=2                         ! Angaben für DEFFILL
  971.   muster2=4                         !     "    "    "
  972.   block!=FALSE                      ! Flag zur Markierung, ob Blockoperation
  973.   '
  974.   DEFFILL 1,muster1,muster2         ! vorgegebenes Füllmuster: grau
  975. RETURN
  976. '
  977. PROCEDURE titelbild
  978.   '
  979.   DEFTEXT 1,16,0,32
  980.   TEXT 20,40,"# Zeichentrickfilmprogramm #######"
  981.   DEFTEXT 1,0,0,13
  982.   '
  983.   BOX 20,200,270,350                               ! Kästen für Filmbilder
  984.   BOX 270,200,520,350
  985.   GET 21,201,269,349,bild$(0)                      ! leeres Bild
  986.   bild$(1)=bild$(0)
  987.   '
  988.   TEXT 25,75,"   Film         Film        Film      Füllmuster  Liniendicke    Figuren   "
  989.   TEXT 25,95," speichern      laden     abspielen   auswählen      (1)       ausfüllen"
  990.   TEXT 25,135," ausfüllen     Block        Kreis      Ellipse      Gerade       Kasten"
  991.   '
  992.   FOR i%=20 TO 520 STEP 100                      ! obere Kastenreihe
  993.     BOX i%,50,i%+100,110
  994.   NEXT i%
  995.   '
  996.   FOR i%=20 TO 520 STEP 100                      ! zweite Kastenreihe
  997.     BOX i%,110,i%+100,170
  998.   NEXT i%
  999.   '
  1000.   FOR i%=200 TO 360 STEP 20                      ! Kästen rechts neben Bildern
  1001.     BOX 540,i%,620,i%+20
  1002.   NEXT i%
  1003.   '
  1004.   TEXT 545,215,"rückwärts"
  1005.   TEXT 545,235,"vorwärts"
  1006.   TEXT 545,255,"merken"
  1007.   TEXT 545,275,"einsetzen"
  1008.   TEXT 545,295,"löschen"
  1009.   TEXT 545,315,"entfernen"
  1010.   TEXT 545,335,"erweitern"
  1011.   TEXT 545,355,"alles weg"
  1012.   TEXT 545,375,"zu Bild.."
  1013.   '
  1014.   BOX 20,360,130,380                            ! Kasten unten links
  1015.   TEXT 25,375,"Programmende"
  1016.   '
  1017.   TEXT 278,375,"⇧  ⇩  ⇨  ⇦         ⇨"
  1018.   FOR i%=270 TO 350 STEP 24                      ! Kästen unter rechtem Bild
  1019.     BOX i%,360,i%+24,380
  1020.   NEXT i%
  1021.   '
  1022.   BOX 405,360,460,380
  1023.   BOX 410,365,425,375
  1024.   BOX 440,365,455,375
  1025.   '
  1026.   SGET titelbild$
  1027.   TEXT 270,195," Bild "+STR$(bild%)+" (von "+STR$(endbild%)+") "
  1028.   PBOX 20,140,120,170
  1029.   '
  1030. RETURN
  1031. '
  1032. PROCEDURE ende
  1033.   ALERT 2,"   Soll das Programm   | wirklich beendet werden?",2,"  ja  | nein ",antw
  1034.   IF antw=1
  1035.     EDIT                                        ! später SYSTEM einsetzen
  1036.   ENDIF
  1037. RETURN
  1038. '
  1039. PROCEDURE reparatur                             ! Bild reparieren, falls
  1040.   SPUT titelbild$                               ! das neue Bild den Rand
  1041.   TEXT 449,95,"("+STR$(breite)+")  "            ! zerstört hat.
  1042.   TEXT 430,195,text$
  1043.   PUT 21,201,bild$(bild%-1)
  1044.   PUT 271,201,bild$(bild%)
  1045.   TEXT 270,195," Bild "+STR$(bild%)+" (von "+STR$(endbild%)+")    "
  1046.   TEXT 430,195,text$
  1047.   DEFFILL 1,muster1,muster2
  1048.   PBOX 20,140,120,170
  1049.   DEFMOUSE 0
  1050.   DEFLINE 1,breite,2,2
  1051.   figurfuellen!=FALSE
  1052. RETURN
  1053. '
  1054. PROCEDURE b_hoch
  1055.   SUB b1%,b
  1056.   SUB b2%,b
  1057.   IF b2%<200
  1058.     ADD b1%,b
  1059.     ADD b2%,b
  1060.   ENDIF
  1061. RETURN
  1062. '
  1063. PROCEDURE b_runter
  1064.   ADD b1%,b
  1065.   ADD b2%,b
  1066.   IF b1%>350
  1067.     SUB b1%,b
  1068.     SUB b2%,b
  1069.   ENDIF
  1070. RETURN
  1071. '
  1072. PROCEDURE b_rechts
  1073.   ADD a1%,b
  1074.   ADD a2%,b
  1075.   IF a1%>520
  1076.     SUB a1%,b
  1077.     SUB a2%,b
  1078.   ENDIF
  1079. RETURN
  1080. '
  1081. PROCEDURE b_links
  1082.   SUB a1%,b
  1083.   SUB a2%,b
  1084.   IF a2%<270
  1085.     ADD a1%,b
  1086.     ADD a2%,b
  1087.   ENDIF
  1088. RETURN
  1089. '
  1090. PROCEDURE b_merken
  1091.   GRAPHMODE 3
  1092.   BOX a1%,b1%,a2%,b2%
  1093.   GET a1%,b1%,a2%,b2%,merk$
  1094.   '
  1095.   DEFFILL 1,2,8                         ! gemerkten Block kurz invertieren
  1096.   PBOX a1%,b1%,a2%,b2%
  1097.   PAUSE 20
  1098.   PBOX a1%,b1%,a2%,b2%
  1099.   DEFFILL 1,muster1,muster2
  1100.   '
  1101.   BOX a1%,b1%,a2%,b2%
  1102.   GRAPHMODE 1
  1103.   block_gemerkt!=TRUE
  1104.   text$="Block aus Bild "+STR$(bild%)+" gemerkt"
  1105.   TEXT 430,195,text$
  1106.   ' GOSUB block
  1107.   REPEAT
  1108.   UNTIL MOUSEK=0
  1109. RETURN
  1110. '
  1111. ' Die folgende Procedure stammt aus dem Buch "GFA BASIC" von F. Ostrowski
  1112. '
  1113. PROCEDURE b_einsetzen
  1114.   DIM bild%(32255/4)
  1115.   a%=XBIOS(3)
  1116.   b%=(VARPTR(bild%(0))+255) AND &HFFFF00
  1117.   SGET bildschirm$
  1118.   REPEAT
  1119.     SWAP a%,b%
  1120.     VOID XBIOS(5,L:a%,L:b%,-1)
  1121.     SPUT bildschirm$
  1122.     MOUSE x%,y%,k%
  1123.     PUT x%,y%,merk$
  1124.     IF k%=1                       ! Block kann beliebig eingesetzt werden.
  1125.       SGET bildschirm$            ! egal, ob Bildschirmrest überdeckt wird,
  1126.     ENDIF                         ! da Reparatur erfolgt
  1127.   UNTIL k%=2
  1128.   a%=MAX(a%,b%)
  1129.   VOID XBIOS(5,L:a%,L:a%,-1)
  1130.   SPUT bildschirm$
  1131.   GET 271,201,519,349,bild$(bild%)
  1132.   ERASE bild%()
  1133.   GOSUB reparatur
  1134. RETURN
  1135. '
  1136. PROCEDURE b_loeschen
  1137.   IF k%=2
  1138.     DEFFILL 0,2,8
  1139.     PBOX a1%+1,b1%+1,a2%-1,b2%-1
  1140.     DEFFILL 1,muster1,muster2
  1141.     z=8
  1142.     GOSUB block
  1143.   ENDIF
  1144. RETURN
  1145.